home *** CD-ROM | disk | FTP | other *** search
/ Trading on the Edge / Trading On The Edge - CD-ROM Toolkit (Wayzata Technology)(2031)(1994).bin / pc / mac_file / vendor_d / ga_softw / ooga / tutorial.lis < prev    next >
Lisp/Scheme  |  1991-02-03  |  14KB  |  470 lines
  1. ;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
  2. #||
  3.             RESTRICTED RIGHTS LEGEND
  4.                     
  5.  Use, duplication, or disclosure by the Government is subject to
  6.  restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  7.  Technical Data and Computer Software Clause at 52.227-7013 of the DOD
  8.  FAR Supplement.
  9.                     
  10.                 TSP (The Software Partnership)
  11.                 P.O. Box 991
  12.                 Melrose, MA 02176
  13.                     
  14.       Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
  15. ||#
  16.  
  17. (in-package :ooga)
  18.  
  19.  
  20.  
  21. ;************************************************************
  22.  
  23. ;     DRIVER FUNCTION
  24.  
  25.  
  26. ;;; TO RUN ANY OF THE EXAMPLES, USE
  27. ;;; (trial-run <example-name>)
  28.  
  29. ;;;  EXAMPLE:   to see an example of GA 1-1, use
  30. ;;;     (trial-run 'ga-1-1)
  31.  
  32. (defun TRIAL-RUN (genetic-algorithm-type)
  33.   (setf *ga* (make-instance genetic-algorithm-type))
  34.   (run *ga*))
  35.  
  36.  
  37. ;************************************************************
  38.  
  39. ;     TEST GA
  40.  
  41. ;;; Use this GA to determine whether OOGA has loaded.  After
  42. ;;; loading, type (trial-run 'test-ga) into Lisp.  If all is
  43. ;;; well, the test GA will run for 40 evaluations and stop with
  44. ;;; a display of the top five chromosomes in the population.
  45.  
  46. (defclass TEST-GA (ga-1-1) ())
  47.  
  48.  
  49. (def-append-method GET-PARTICULARS ((ga test-ga))
  50.     `((population-size 10)
  51.       (desired-trials 40)))
  52.     
  53.  
  54. ;************************************************************
  55.  
  56. ;    FIRST INHERITANCE HIERARCHY
  57.  
  58. ;************************************************************
  59.  
  60. ;    GA-1-1
  61.  
  62. ;; GA-1-1 is the basic GA that GA's 1-2 through 3-4 will be
  63. ;; built on.
  64.  
  65. (defclass GA-1-1 (basic-genetic-algorithm) ())
  66.  
  67. ;;; We don't use any component GA with slot values.  
  68. ;;; Fill in the particulars.
  69. (def-append-method GET-PARTICULARS ((ga ga-1-1))
  70.     `((evaluator ,(make-instance 'binary-f6))
  71.       (population-size 100)
  72.       (desired-trials 4000)
  73.       (fitness-technique ,(make-instance 'fitness-is-evaluation))
  74.       (parent-selection-technique
  75.     ,(make-instance 'roulette-wheel-parent-selection))
  76.       (representation-technique
  77.     ,(make-instance 'binary-representation
  78.             :bit-string-length 44))
  79.       (initialization-technique
  80.     ,(make-instance 'random-binary-initialization))
  81.       (reproduction-technique
  82.     ,(make-instance 'generational-replacement))
  83.       (deletion-technique ,(make-instance 'delete-all))
  84.       (operator-selection-technique
  85.     ,(make-instance 'use-first-operator))
  86.       (operator-list
  87.     ,(list (make-instance 'one-point-crossover-and-mutate)))))
  88.  
  89.  
  90. ;************************************************************
  91.  
  92. ;    GA-2-1
  93.  
  94.  
  95. (defclass GA-2-1 (ga-1-1) ())
  96.  
  97. ;;; Replace fitness-is-evaluation with linear-normalization
  98. (def-append-method GET-PARTICULARS ((ga ga-2-1))
  99.     `((fitness-technique
  100.     ,(make-instance 'linear-normalization))))
  101.  
  102.  
  103. ;************************************************************
  104.  
  105. ;    GA-2-2
  106.  
  107. (defclass GA-2-2 (ga-2-1) ())
  108.  
  109. ;;; Add elitism to generational replacement
  110. (def-append-method GET-PARTICULARS ((ga ga-2-2))
  111.     `((reproduction-technique
  112.     ,(make-instance 'generational-replacement-with-elitism))))
  113.  
  114.  
  115. ;************************************************************
  116.  
  117. ;    GA-2-3
  118.  
  119. (defclass GA-2-3 (ga-2-1) ())
  120.  
  121. ;;; Replace generational replacement with steady-state reproduction
  122. (def-append-method GET-PARTICULARS ((ga ga-2-3))
  123.     `((reproduction-technique ,(make-instance 'steady-state))
  124.       (deletion-technique ,(make-instance 'delete-last))))
  125.  
  126.  
  127. ;************************************************************
  128.  
  129. ;    GA-2-4
  130.  
  131. (defclass GA-2-4 (ga-2-3) ())
  132.  
  133. ;;; Add no duplicates to steady state.
  134. (def-append-method GET-PARTICULARS ((ga ga-2-4))
  135.     `((reproduction-technique
  136.     ,(make-instance 'steady-state-without-duplicates))))
  137.  
  138.  
  139. ;************************************************************
  140.  
  141. ;    GA-2-5
  142.  
  143. (defclass GA-2-5 (ga-2-4) ())
  144.  
  145. ;;; Increase mutation and crossover rates in basic operator
  146. (def-append-method GET-PARTICULARS ((ga ga-2-5))
  147.     `((operator-list
  148.     ,(list (make-instance 'one-point-crossover-and-mutate
  149.                   :bit-mutation-rate .04
  150.                   :crossover-rate .8)))))
  151.  
  152.  
  153. ;************************************************************
  154.  
  155. ;    RANDOM BINARY-F6
  156.  
  157. ;;;  (used for tests of random generate and search)
  158.  
  159.  
  160. (defclass RANDOM-BINARY-F6
  161.       (ga-2-5)
  162.      ())
  163.  
  164. ;;; Generate random individuals rather than using existing parents.
  165. (def-append-method GET-PARTICULARS ((ga random-binary-f6))
  166.     `((operator-list
  167.     ,(list (make-instance 'random-bit-string-generation)))
  168.       (operator-weights '(100))))
  169.  
  170.  
  171. ;************************************************************
  172.  
  173. ;    GA-3-1
  174.  
  175. ;;; GA 3-1 is a steady-state binary f6 GA.  It is the GA that 
  176. ;;; GA's 3-2 through 3-4 will be built on.
  177.  
  178.  
  179. (defclass GA-3-1 (ga-2-4) ())
  180.  
  181. ;;; Separate the two operators
  182. (def-append-method GET-PARTICULARS ((ga ga-3-1))
  183.     `((operator-list
  184.     ,(list (make-instance 'one-point-crossover)
  185.            (make-instance 'binary-mutation
  186.                   :bit-mutation-rate .04)))
  187.       (operator-weights ,(list 60 40))))
  188.  
  189.  
  190. ;************************************************************
  191.  
  192. ;    GA-3-2
  193.  
  194.  
  195. (defclass GA-3-2 (ga-3-1) ())
  196.  
  197. ;;; Replace two-point crossover with uniform crossover.
  198. (def-append-method GET-PARTICULARS ((ga ga-3-2))
  199.     `((operator-list
  200.     ,(list (make-instance 'uniform-list-crossover)
  201.            (make-instance 'binary-mutation
  202.                   :bit-mutation-rate .04)))))
  203.  
  204.  
  205. ;************************************************************
  206.  
  207.  
  208. ;    GA-3-3
  209.  
  210.  
  211. (defclass GA-3-3
  212.       (ga-3-2)
  213.      ())
  214.  
  215. ;;; Interpolate operator weights
  216. (def-append-method GET-PARTICULARS ((ga ga-3-3))
  217.     `((reproduction-parameterization-techniques
  218.     ,(list (make-instance 'interpolate-operator-weights
  219.                   :interpolation-specs '((70 30) (50 50)))))))
  220.  
  221.  
  222.  
  223. ;************************************************************
  224.  
  225. ;    GA-3-4
  226.  
  227.  
  228. (defclass GA-3-4
  229.       (ga-3-3)
  230.      ())
  231.  
  232. ;;; Interpolate the fitness decrement
  233. (def-append-method GET-PARTICULARS ((ga ga-3-4))
  234.     `((population-parameterization-techniques
  235.     ,(list (make-instance
  236.          'interpolate-fitness-decrement)))))
  237.  
  238.  
  239. ;************************************************************
  240.  
  241. ;    SECOND GA HIERARCHY
  242.  
  243. ;************************************************************
  244.  
  245. ;    GA-5-1
  246.  
  247. ;;; GA 5-1 is a real-valued GA.
  248. (defclass GA-5-1 (basic-genetic-algorithm) ())
  249.  
  250. ;;; We're not using a component GA in the tutorial, so we'll build
  251. ;;; this GA from scratch.
  252. (def-append-method GET-PARTICULARS ((ga ga-5-1))
  253.     `((evaluator ,(make-instance 'real-number-f6))
  254.       (population-size 100)
  255.       (desired-trials 4000)
  256.       (fitness-technique ,(make-instance 'linear-normalization))
  257.       (parent-selection-technique
  258.     ,(make-instance 'roulette-wheel-parent-selection))
  259.       (representation-technique
  260.     ,(make-instance 'real-number-representation))
  261.       (initialization-technique
  262.     ,(make-instance 'random-real-number-initialization))
  263.       (reproduction-technique
  264.     ,(make-instance 'steady-state-without-duplicates))
  265.       (deletion-technique ,(make-instance 'delete-last))
  266.       (population-parameterization-techniques
  267.     ,(list (make-instance 'interpolate-fitness-decrement)))
  268.       (operator-selection-technique
  269.     ,(make-instance 'roulette-wheel-operator-selection))
  270.       (operator-list
  271.     ,(list (make-instance 'uniform-list-crossover)
  272.         (make-instance 'average-crossover)
  273.         (make-instance 'real-number-mutation)
  274.         (make-instance 'real-number-creep
  275.                :creep-specs '((70000 t)))
  276.         (make-instance 'real-number-creep
  277.                :creep-specs '((2000 t)))))
  278.       (operator-weights ,(list 10 40 10 30 10))
  279.       (reproduction-parameterization-techniques
  280.     ,(list (make-instance
  281.           'interpolate-operator-weights
  282.           :interpolation-specs
  283.           '((10 40 10 30 10) (10 20 0 40 30)))))))
  284.  
  285.  
  286. ;************************************************************
  287.  
  288. ;    GA 6-1
  289.  
  290. ;;; GA 6-1 is the node-coloring order-based GA.
  291. ;;; It shares some of the techniques of GA-5-1.
  292. (defclass GA-6-1 (ga-5-1) ())
  293.  
  294. ;;; Particularize for the node-coloring problem.
  295. (def-append-method GET-PARTICULARS ((ga ga-6-1))
  296.     `((evaluator ,(make-instance 'node-coloring-evaluator))
  297.       (representation-technique ,(make-instance 'permuted-list))
  298.       (initialization-technique ,(make-instance 'random-permutation))
  299.       (operator-list
  300.     ,(list (make-instance 'uniform-order-based-crossover)
  301.            (make-instance 'scramble-sublist-mutation)))
  302.       (operator-weights '(60 40))
  303.       (reproduction-parameterization-techniques
  304.     ,(list (make-instance
  305.          'interpolate-operator-weights
  306.          :interpolation-specs '((70 30) (50 50)))))))
  307.  
  308.  
  309. ;;; Need new display method for displaying the best solution.
  310. (defmethod DISPLAY-BEST-SOLUTION ((ga ga-6-1))
  311.   (format *standard-output* "~%~%BEST SOLUTION HAS EVALUATION ~A"
  312.       (evaluation (first-member (population-module ga))))
  313.   (loop for node in (chromosome (first-member (population-module ga)))
  314.     do (format *standard-output* "~%~a  ~a  ~a"
  315.            (index node) (weight node) (color node))))
  316.  
  317.  
  318. ;************************************************************
  319.  
  320. ;    RANDOM NODE-COLORING
  321.  
  322. ;;; A benchmark for comparison.  This GA just generates random
  323. ;;; permutations of the node list.
  324. (defclass RANDOM-NODE-COLORING (ga-6-1) ())
  325.  
  326. ;;; Only use the random generation operator.  Ignore parents.
  327. (def-append-method GET-PARTICULARS ((ga random-node-coloring))
  328.     `((operator-list ,(list (make-instance 'random-order-generation)))
  329.       (operator-weights ,(list 100))
  330.       (population-parameterization-techniques nil)
  331.       (reproduction-parameterization-techniques nil)))
  332.  
  333.  
  334. ;************************************************************
  335.  
  336. ;;;    GA 7-1 -- ADAPTS OPERATOR WEIGHTS FOR GA 5-1 AND FINDS
  337. ;;;    GOOD INITIAL WEIGHT LISTS
  338.  
  339.  
  340. ;;; Use (find-initial-operator-weights (make-instance 'ga-7-1))
  341. ;;; to see the system find appropriate starting operator weights.
  342.  
  343. ;;; NOTE: The weights found should differ from those in the Handbook.
  344. ;;; The Handbook algorithm has been replaced by a better one here.
  345. ;;; This algorithm finds weights in the vicinity of (10 55 15 15 5).
  346.  
  347.  
  348. ;;; Use (trial-run 'ga-7-1) to see the weights adapt during a run.
  349.  
  350.  
  351. (defclass GA-7-1
  352.       (ga-5-1 adapt-initial-operator-weights) ()
  353.      (:default-initargs
  354.        :population-module (make-instance 'population-module-7-1)
  355.        :reproduction-module (make-instance 'reproduction-module-7-1)))
  356.        
  357.  
  358. (defclass POPULATION-MODULE-7-1
  359.       (trace-operator-weights
  360.          adaptive-operator-module
  361.         basic-population-module)
  362.      ())
  363.  
  364.  
  365. (defclass REPRODUCTION-MODULE-7-1
  366.       (adaptive-reproduction-module) ())
  367.  
  368.  
  369. (def-append-method GET-PARTICULARS ((ga ga-7-1))
  370.     `((population-member-class adaptation-population-member)
  371.       (reproduction-parameterization-techniques nil)
  372.       (initial-operator-weights (10 40 10 30 10))))
  373.  
  374.  
  375. ;************************************************************
  376.  
  377. ;    PERFORMANCE GRAPHS
  378.  
  379. (defun GET-NINE-COUNT-STATISTICS (ga-type &optional (runs 20))
  380.   (setf *ga* (make-instance ga-type))
  381.   (setf (display-flag (population-module *ga*)) nil)
  382.   (format t "~%PERFORMANCE RUN OF ~A:" ga-type)
  383.   (loop for x from 1 to runs do (format t "  ~a"  x)
  384.                   (run *ga*))
  385.   (format t "~%~%NINE-COUNT PERFORMANCE:")
  386.   (loop for stat in (reverse (average-nines-performance (population-module *ga*)))
  387.     do (format t "~%~a  ~a" (car stat) (cadr stat))))
  388.  
  389.  
  390. (defun GET-PERFORMANCE-STATISTICS (ga-type &optional (runs 20))
  391.   (setf *ga* (make-instance ga-type))
  392.   (setf (display-flag (population-module *ga*)) nil)
  393.   (format t "~%PERFORMANCE RUN OF ~A:" ga-type)
  394.   (loop for x from 1 to runs do (format t "  ~a"  x)
  395.                   (run *ga*))
  396.   (format t "~%~%PERFORMANCE:")
  397.   (loop for stat in (reverse (average-performance (population-module *ga*)))
  398.     do (format t "~%~a  ~a" (car stat) (cadr stat))))
  399.  
  400.  
  401. (defmethod AVERAGE-NINES-PERFORMANCE ((population-module basic-population-module))
  402.   (let* ((list (performance-statistics population-module))
  403.      (length (length list))
  404.      (nine-totals (sum-nine-cadrs list)))
  405.     (loop for x in nine-totals
  406.       collect (list (car x) (/ (cadr x) (float length))))))
  407.  
  408.  
  409. (defun SUM-NINE-CADRS (list)
  410.   "Sum the decimal nines in cadrs of parallel conses across the lists in the list"
  411.   (loop for sublist in (cdr list)
  412.     with sum = (loop for item in (car list)
  413.              collect (list (car item) (count-decimal-nines (cadr item))))
  414.     do (loop for item in sublist
  415.          for total in sum
  416.          do (setf (cadr total) (+ (cadr total) (count-decimal-nines (cadr item)))))
  417.     finally (return sum)))
  418.  
  419.  
  420. (defun GA-1-1-AVERAGE ()
  421.   (declare (special g))
  422.   (setf g (make-instance 'ga-1-1))
  423.   (setf (display-flag (population-module g)) nil)
  424.   (run g)
  425.   (loop for x below 20 with mini = nil with maxi = nil with av = nil
  426.     do (initialize-population (population-module g))
  427.     (format t "  ~a" x)
  428.     (setf mini (cons (apply 'min (evaluations (population-module g))) mini)
  429.           maxi (cons (apply 'max (evaluations (population-module g))) maxi)
  430.           av (cons (average (evaluations (population-module g))) av))
  431.     finally (format t "~%~%MIN ~a   Max  ~a  Av  ~a"
  432.             (average mini) (average maxi) (average av))))
  433.  
  434.  
  435. ;************************************************************
  436.  
  437. ;    RANDOM GENERATION OF BIT STRINGS FOR F6
  438.  
  439.  
  440. (defclass GA-F6-RANDOM
  441.       (ga-2-3)
  442.      ())
  443.  
  444.  
  445. (defmethod INITIALIZE-INSTANCE :AFTER ((ga ga-f6-random) &rest args)
  446.   (declare (ignore args))
  447.   (setf (operator-list (reproduction-module ga))
  448.                (list (make-instance 'random-bit-string-generation)))
  449.   (setf (operator-selection-technique (reproduction-module ga))
  450.     (make-instance 'use-first-operator)))
  451.  
  452.  
  453.  
  454. ;************************************************************
  455.  
  456. ;    RANDOM GENERATION OF PERMUTATIONS FOR NODE COLORING
  457.  
  458.  
  459. (defclass GA-NODE-COLOR-RANDOM
  460.       (ga-6-1)
  461.      ())
  462.  
  463.  
  464. (defmethod INITIALIZE-INSTANCE :AFTER ((ga ga-node-color-random) &rest args)
  465.   (declare (ignore args))
  466.   (setf (operator-list (reproduction-module ga))
  467.                (list (make-instance 'random-order-generation)))
  468.   (setf (operator-selection-technique (reproduction-module ga))
  469.     (make-instance 'use-first-operator)))
  470.